home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 03 - 1987 / 03.09 Sep 87 / forth source / Event Poster Fkey.edit next >
Encoding:
Text File  |  1987-08-06  |  4.7 KB  |  207 lines  |  [TEXT/EDIT]
  1. ( *** Function Key example. JL June 1987 *** )
  2.  
  3. ONLY FORTH ALSO ASSEMBLER ALSO MAC
  4.  
  5. 4ascii QD15 CONSTANT "qd15
  6. 4ascii bplt CONSTANT "bplt
  7. 4ascii DITL CONSTANT "ditl
  8. 4ascii DLOG CONSTANT "dlog
  9.  
  10. 2 CONSTANT post.delay     ( 2 ticks wait between posting of characters )
  11. 10 CONSTANT max.events    ( max # of pending events allowed during posting )
  12.  
  13. $14a CONSTANT EvQHdr
  14. $29A CONSTANT JGNEFilter
  15. 2 CONSTANT QHead
  16. 6 CONSTANT QTail
  17.  
  18. BINARY 0000000000001000 CONSTANT KeyEvent
  19. DECIMAL
  20.  
  21. ( header code filled at end of definitions )
  22. header start
  23.     JMP start  ( to be filled later )
  24. header temprect 8 allot
  25. header itemrect 8 allot
  26. header myEventRec 16 allot
  27.  
  28. : beep 5 (call) sysbeep ;
  29.  
  30. CODE cmove ( redefine since this is part of Kernel )
  31.     MOVE.L    (A6)+,D0
  32.     MOVE.L    (A6)+,A1
  33.     MOVE.L    (A6)+,A0
  34.     TST.L    D0
  35.     BLE.S    @2
  36. @1    MOVE.B    (A0)+,(A1)+
  37.     SUBQ.L    #1,D0
  38.     BNE.S    @1
  39. @2    RTS
  40. END-CODE
  41.  
  42. : / w/ ;
  43.  
  44. : getFkeyDlg 
  45.     2000 0 -1 (call) GetNewDialog 
  46. ;
  47.  
  48. : #events EvQHdr QTail + @ EvQHdr QHead + @ - 22 / ;
  49.  
  50. : post.char ( char -- ) 3 swap (call) postEvent drop
  51. ;
  52.  
  53. header SavedJGNEFilter 4 allot
  54. header SavedString 256 allot
  55. header bytesToTransfer 4 allot
  56. header lastpost 4 allot
  57.  
  58. : GNEIntfc { | btt -- }
  59.     getA1 w@ 0= IF
  60.     ['] bytesToTransfer @ -> btt
  61.     btt IF  (call) tickcount ['] lastpost @ - post.delay > 
  62.         #events max.events < AND 
  63.         IF
  64.             ['] SavedString dup c@ btt - 1+
  65.             + c@ post.char
  66.             btt 1- ['] bytesToTransfer !
  67.             (call) tickcount ['] lastpost !
  68.         THEN
  69.     ELSE
  70.     ['] savedJGNEFilter @ JGNEFilter !
  71.     THEN
  72.     THEN
  73. ;
  74.     
  75. CODE GNE.glue
  76.     LINK    A6,#-256         ( 256 bytes of local Forth stack )
  77.     MOVEM.L A0-A5/D0-D7,-(A7)    ( save registers )
  78.                     ( no need for loop return stack )
  79.                     ( no parameters are passed )
  80.     JSR GNEintfc            ( call Forth routine )
  81.  
  82.     MOVEM.L (A7)+,A0-A5/D0-D7    ( restore registers )
  83.     UNLK    A6
  84.     LEA    SavedJGNEFilter,A0
  85.     MOVE.L    (A0),A0    ( return address )
  86.     JMP    (A0)
  87. END-CODE
  88.  
  89. : post.string { string | length -- }
  90.     string c@ -> length
  91.     string ['] SavedString length 1+ cmove
  92.     length ['] bytesToTransfer !
  93.     (call) tickcount ['] lastpost !
  94.     JGNEFilter @ ['] SavedJGNEFilter !
  95.     ['] GNE.glue JGNEFilter !
  96. ;
  97.  
  98. : post.message { msg# | dh dPtr tPtr -- }
  99.     " FKEY.messages" (call) OpenResFile (call) UseResFile
  100.     "bplt msg# 3 + (call) getResource -> dh
  101.     dh IF dh @ post.string
  102.     ELSE beep THEN
  103. ;
  104.  
  105. : edit.messages { | dPtr itemType item box box1 itemHit thandle refnum -- }
  106.     " FKEY.messages" dup (call) OpenResFile
  107.     (call) ResError 
  108.         IF drop dup (call) CreateResFile
  109.             (call) OpenResFile dup -> refNum 
  110.             (call) UseResFile 
  111.         ELSE dup -> refNum 
  112.             (call) UseResFile drop 
  113.         THEN    
  114.     getFkeyDlg -> dPtr
  115.         dPtr IF    
  116.             13 3 DO 
  117.             dPtr i ^ itemType ^ item ^ box
  118.                 (call) GetDItem
  119.             item (call) HLock drop
  120.             "bplt i (call) GetResource -> thandle
  121.             thandle IF 
  122.                 thandle (call) HLock drop
  123.                 item thandle @ (call) SetIText 
  124.                 thandle (call) HUnlock drop 
  125.                 ELSE
  126.                 256 (call) NewHandle drop
  127.                 "bplt i " Message" (call) AddResource
  128.                 THEN
  129.             item (call) HUnlock drop
  130.             LOOP    ( all messages have been initialized )
  131.  
  132.         0 ^ itemHit (call) ModalDialog
  133.  
  134.             13 3 DO 
  135.             dPtr i ^ itemType ^ item ^ box
  136.                 (call) GetDItem
  137.             item (call) HLock drop
  138.             "bplt i (call) GetResource -> thandle
  139.             thandle IF 
  140.                 thandle (call) HLock drop
  141.                 item thandle @ (call) GetIText
  142.                 thandle (call) ChangedResource 
  143.                 thandle (call) HUnlock drop THEN
  144.             item (call) HUnlock drop
  145.             LOOP    ( all messages have been updated )
  146.         refNum (call) UpdateResFile
  147.         dPtr (call) DisposDialog
  148.         ELSE beep THEN
  149. ;
  150.  
  151. : fkey { | keycode -- }
  152.     (call) frontwindow windowkind + w@ l_ext dup
  153.     2 = swap 0< OR 0= IF 
  154.     BEGIN KeyEvent ['] myEventRec (call) GetNextEvent UNTIL
  155.  
  156.     ['] myEventRec message + @ $FF and -> keycode
  157.         keycode ascii e = 
  158.         IF edit.messages 
  159.         ELSE
  160.         keycode ascii 0 < keycode ascii 9 > OR
  161.             IF beep ELSE keycode 48 - post.message
  162.             THEN 
  163.         THEN
  164.     ELSE beep 
  165.     THEN
  166. ;
  167.  
  168. ( *** our standard glue routine *** )
  169.  
  170. CODE fkey.glue
  171.     LINK    A6,#-2048             ( 2K bytes of local Forth stack )
  172.     MOVEM.L A0-A5/D0-D7,-(A7)    ( save registers )
  173.     MOVE.L A6,A3            ( setup local loop return stack )
  174.     SUBA.L #256,A3            ( starting 256 bytes below locals )
  175.                         ( no parameters are passed to the FKEY )
  176.     JSR fkey                ( call Forth routine )
  177.  
  178.     MOVEM.L (A7)+,A0-A5/D0-D7    ( restore registers )
  179.     UNLK    A6
  180.     MOVE.L    (A7)+,A0        ( return address )
  181.     JMP    (A0)
  182. END-CODE
  183.  
  184. header end
  185.  
  186. ( install initial jump vector )
  187. ' fkey.glue ' start 2+ - ' start 2+ w!
  188.  
  189. ( *** installation *** )
  190.  
  191. : make.fkey { | refNum namePtr -- }
  192.     " fkey.text" dup $create-res
  193.     abort" You have to delete the old 'fkey.text' file first."
  194.     $open-res dup -> refNum call UseResFile 
  195.     ['] start ['] end over - call PtrToHand drop ( result code )
  196.         "fkey 5 " Mach2 FKEY" call AddResource
  197.     refNum $close-res drop ( result code )
  198.     0 " fkey.text" 
  199.         getvol ioVRefNum + w@ l_ext
  200.         getfileinfo drop
  201.     "qd15 "fkey " fkey.text" setfileinfo
  202. ;
  203.  
  204.      
  205.  
  206.  
  207.